home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / icon / contrib / debug.lha / debugify.ic0 < prev    next >
Text File  |  1992-09-06  |  20KB  |  567 lines
  1. ############################################################################
  2. #
  3. #   Name:       debugify.ic0 / debugify.icn
  4. #
  5. #   Title:      Create a ucode file with hooks to __debug_proc
  6. #
  7. #   Author:     Charles A. Shartsis
  8. #
  9. #   Date:       December 29, 1991
  10. #
  11. #   Version:    1.01
  12. #
  13. ############################################################################
  14. #
  15. # See documentation in DEBUGIFY.DOC
  16. #
  17. ############################################################################
  18.  
  19. link radcon
  20.  
  21. global ws, nonws, label_prefix, labelno, high_labels, tmpname, builtin_tab
  22. global line, curproc, lineno, fname, symbol_id, symbol_type, symbol_name
  23. global con_id, con_type, first_filename, debug_proc_name, debug_proc_id
  24. global next_symbol_id, last_symbol_id, name_list_name, val_list_name
  25. global put_id, variable_id, name_list_id, val_list_id
  26. global last_con_id, next_con_id, proc_symbols, save_label, index_id, one_id
  27. global index_name, tmpfile, cur_sym_name, symbol_list, proc_name_id
  28. global modify, includes, include_procs, infile_name, infile
  29. global andfileid, andlineid, version
  30.     
  31.  
  32. # Add __debug var or nodebug var & inhibit branch
  33. # DEBUGIFY SEQ
  34. procedure main(argv)
  35.  
  36.     # DO NOT MODIFY, MOVE, OR DELETE THIS COMMENT LINE
  37.     (\andfileid & \andlineid & \version) | stop(&errout, "Debugify not configured.")
  38.     write(&errout, "Debugify running: Configured for Icon Version ", version)
  39.  
  40.     # Process command line options
  41.     modify := &null
  42.     includes := &null
  43.     include_procs := table(&null)
  44.     infile_name := "-"
  45.     process_options(argv)
  46.     if infile_name == "-" then {
  47.         infile := &input
  48.     }
  49.     else {
  50.         (infile := open(infile_name, "r")) | stop(&errout, "Cannot open input file ", infile_name)
  51.     }
  52.  
  53.     ws := ' \t'
  54.     nonws := &ascii -- ws
  55.     debug_proc_name := "__debug_proc"
  56.     name_list_name := "__names"
  57.     val_list_name := "__vals"
  58.     label_prefix := "L"
  59.     index_name := "__i"
  60.     high_labels := table(0)
  61.     tmpname := "debugify.tmp"
  62.     do_builtins()
  63.     
  64.     # Get high labels for each proc
  65.     get_high_labels()
  66.     
  67.     (tmpfile := open(tmpname, "r")) | stop(&errout, "Cannot open ", tmpname,"  for input")
  68.     
  69.     line := (read(tmpfile) | &null)
  70.     
  71.     # BODY ITR UNTIL EOF
  72.     until /line do {
  73.     
  74.         # PROC SEQ
  75.         curproc := &null
  76.         line ? {
  77.             cstar(ws) & ="proc" & cplus(ws) &
  78.             (curproc <- tab(many(nonws))) &
  79.             cstar(ws) & pos(0)
  80.         }
  81.         \curproc | stop(&errout, "invalid proc line:",line)
  82.  
  83.         # Reset proc values
  84.         last_symbol_id := 0
  85.         last_con_id := 0
  86.         labelno := high_labels[curproc]
  87.         proc_symbols := table(&null)
  88.         symbol_list := []
  89.         
  90.         write(line)
  91.         
  92.         line := (read(tmpfile) | &null)
  93.         
  94.         
  95.             # SYMBOLS ITR UNTIL END OF LOCAL LIST
  96.             until not (line ? (cstar(ws) & ="local")) do {
  97.             
  98.                 # SYMBOL SEQ
  99.                 
  100.                     symbol_id := &null
  101.                     symbol_type := &null
  102.                     symbol_name := &null
  103.                     line ? {
  104.                         cstar(ws) & ="local" & cplus(ws) &
  105.                         symbol_id <- integer(tab(many(&digits))) & 
  106.                         cstar(ws) & ="," & cstar(ws) &
  107.                         symbol_type <- tab(many(&digits)) & 
  108.                         cstar(ws) & ="," & cstar(ws) &
  109.                         symbol_name <- tab(many(nonws)) &
  110.                         cstar(ws) & pos(0)
  111.                     }
  112.                     \symbol_id | stop(&errout, "invalid symbol line:",line)
  113.                     
  114.                     
  115.                     last_symbol_id := symbol_id
  116.                     if /(builtin_tab[symbol_name]) then proc_symbols[symbol_name] := 1
  117.                     
  118.                     write(line)
  119.                 
  120.                     line := (read(tmpfile) | &null)
  121.                     
  122.                 # SYMBOL END
  123.                 
  124.             # SYMBOLS END
  125.             }
  126.             
  127.             # Install new symbols
  128.             
  129.             if curproc ~== debug_proc_name then {
  130.             
  131.                 next_symbol_id := last_symbol_id + 1
  132.                 write("\tlocal\t", next_symbol_id, ",000000,", debug_proc_name)
  133.                 debug_proc_id := next_symbol_id
  134.             
  135.                 next_symbol_id +:= 1
  136.                 write("\tlocal\t", next_symbol_id, ",000000,put")
  137.                 put_id := next_symbol_id
  138.             
  139.                 next_symbol_id +:= 1
  140.                 write("\tlocal\t", next_symbol_id, ",000000,variable")
  141.                 variable_id := next_symbol_id
  142.             
  143.                 next_symbol_id +:= 1
  144.                 write("\tlocal\t", next_symbol_id, ",000020,", name_list_name)
  145.                 name_list_id := next_symbol_id
  146.             
  147.                 next_symbol_id +:= 1
  148.                 write("\tlocal\t", next_symbol_id, ",000020,", val_list_name)
  149.                 val_list_id := next_symbol_id
  150.             
  151.                 next_symbol_id +:= 1
  152.                 write("\tlocal\t", next_symbol_id, ",000020,", index_name)
  153.                 index_id := next_symbol_id
  154.             
  155.                 next_symbol_id +:= 1
  156.                 
  157.             }
  158.     
  159.             
  160.             # CONSTANTS ITR UNTIL END OF CONSTANT LIST
  161.             until not (line ? (cstar(ws) & ="con")) do {
  162.             
  163.                 #CONSTANT SEQ
  164.                                
  165.                     con_id := &null
  166.                     con_type := &null
  167.                     line ? {
  168.                         cstar(ws) & ="con" & cplus(ws) &
  169.                         con_id <- integer(tab(many(&digits))) & 
  170.                         cstar(ws) & ="," & cstar(ws) &
  171.                         con_type <- tab(many(&digits))
  172.                     }
  173.                     (\con_id) | stop(&errout, "invalid constant line:",line)
  174.                 
  175.                     last_con_id := con_id
  176.                     
  177.                     write(line)
  178.                 
  179.                     line := (read(tmpfile) | &null)
  180.                     
  181.                 #CONSTANT END
  182.                 
  183.                 
  184.             # CONSTANTS END
  185.             }
  186.             
  187.             # Install new string constants for the names of all the 
  188.             # previously existing symbols
  189.             # When finished, proc_symbols will map names of previously
  190.             # existing symbols to their unique constant identifier
  191.             
  192.             if curproc ~== debug_proc_name then {
  193.             
  194.                 next_con_id := last_con_id + 1
  195.  
  196.                 every cur_sym_name := key(proc_symbols) do {
  197.                     writes("\tcon\t", next_con_id, ",010000,", *cur_sym_name)
  198.                     octal_list(cur_sym_name)
  199.                     write("")
  200.                     proc_symbols[cur_sym_name] := next_con_id
  201.                     next_con_id +:= 1
  202.                 }
  203.                 
  204.                 # Install other new constants
  205.                 
  206.                 # The constant 1
  207.                 write("\tcon\t", next_con_id, ",002000,1,1")
  208.                 one_id := next_con_id
  209.                 
  210.                 next_con_id +:= 1
  211.             
  212.                 # The procedure name constant
  213.                 writes("\tcon\t", next_con_id, ",010000,", *curproc)
  214.                 octal_list(curproc)
  215.                 write("")
  216.                 proc_name_id := next_con_id
  217.                 
  218.                 next_con_id +:= 1
  219.             
  220.             }
  221.             
  222.             # DECLEND SEQ
  223.             
  224.                 (line ? (cstar(ws) & ="declend" & cstar(ws) & pos(0))) |
  225.                     stop(&errout, "End Declaration Line not found where expected: ",line)
  226.             
  227.                 write(line)
  228.                         
  229.                 line := (read(tmpfile) | &null)
  230.                         
  231.             # DECLEND END
  232.             
  233.             # FILENAME SEQ
  234.             # The first procedure contains a file name line after the declarations
  235.             
  236.                 if /first_filename then {
  237.                 
  238.                     first_filename := 1
  239.             
  240.                     fname := &null
  241.                     line ? {
  242.                        cstar(ws) & ="filen" & cplus(ws) &
  243.                        (fname <- cplus(nonws)) &
  244.                       cstar(ws) & pos(0)
  245.                     }
  246.                 
  247.                     \fname | stop(&errout, "file name not properly parsed")
  248.                     write(line)
  249.                         
  250.                     line := (read(tmpfile) | &null)
  251.                     
  252.                 }
  253.                         
  254.             # FILENAME END
  255.  
  256.             # Install __names := [ s1, s2, ... ]
  257.             # where s1, s2, ... are the names of previously existing symbols
  258.             if curproc ~== debug_proc_name then {
  259.                 save_label := next_label()
  260.                 write("\tmark\t",save_label)
  261.                 write("\tpnull")
  262.                 write("\tvar\t",name_list_id)
  263.                 write("\tpnull")
  264.                 every write("\tstr\t", (!sort(proc_symbols))[2])
  265.                 write("\tllist\t", *proc_symbols)
  266.                 write("\tasgn")
  267.                 write("\tunmark")
  268.                 write("lab ", save_label)
  269.             }
  270.             
  271.             
  272.             # SOURCE_LINES ITR UNTIL EOF OR END OF PROC
  273.             until (
  274.                 /line |
  275.                 (line ? (cstar(ws) & ="proc" & cplus(ws)))
  276.             ) do {
  277.             
  278.                 # SOURCE_LINE SEQ
  279.                 
  280.                     # LINE_NUMBER SEQ
  281.                     
  282.                     line_number()
  283.                   
  284.                     # LINE_NUMBER END
  285.                     
  286.                     # LINE_BODY ITR UNTIL EOF OR END OF SOURCE LINE
  287.                     
  288.                     line_body()
  289.                         
  290.                     # LINE_BODY END
  291.                     
  292.                 # SOURCE_LINE END
  293.                 
  294.             # SOURCE_LINES END
  295.             }
  296.             
  297.         # PROC END
  298.     
  299.     # BODY END
  300.     }
  301.     
  302.     close(tmpfile)
  303.     remove(tmpname) | stop(&errout, "Unable to delete ", tmpname)
  304.     
  305. # DEBUGIFY END
  306. end
  307.  
  308. procedure cstar(c)
  309.     suspend "" | tab(many(c))
  310. end
  311.  
  312. procedure cplus(c)
  313.     return tab(many(c))
  314. end
  315.  
  316. # Print a string as a list of octal numbers, each preceded by a comma
  317. procedure octal_list(s)
  318.  
  319.     every writes(",",exbase10(ord(!s),8))
  320.     
  321. end
  322.  
  323. procedure next_label()
  324.  
  325.     labelno +:= 1
  326.  
  327.     return label_prefix || labelno
  328.  
  329. end
  330.  
  331. procedure get_high_labels()
  332.  
  333.     local line, labelno, curproc, tmpfile
  334.     
  335.     (tmpfile := open(tmpname,"w")) | stop(&errout, "Unable to open ", tmpname, " for output")
  336.     
  337.     line := (read(infile) | &null)
  338.  
  339.     until /line do {
  340.     
  341.         line ? (
  342.             cstar(ws) & ="proc" & cplus(ws) & 
  343.             curproc <- tab(many(nonws)) & 
  344.             cstar(ws) & pos(0)
  345.         )
  346.     
  347.         labelno := &null
  348.         if line ? (
  349.             ="lab L" & 
  350.             (labelno <- integer(tab(many(&digits)))) &
  351.             cstar(ws) & pos(0)
  352.         ) then {
  353.         
  354.             if labelno > high_labels[curproc] then      
  355.                 high_labels[curproc] := labelno
  356.         }
  357.         
  358.         write(tmpfile, line)        
  359.     
  360.         line := (read(infile) | &null)
  361.         
  362.     }
  363.     
  364.     close(tmpfile)
  365.     
  366. end
  367.  
  368. procedure do_builtins()
  369.  
  370.     local builtin
  371.  
  372.     builtin_tab := table(&null)
  373.     builtin :=
  374.         [ "abs", "any", "args", "bal", "center", "char", "close", "collect", 
  375.         "copy", "cset", "delete", "detab", "display", "entab", "errorclear", 
  376.         "exit", "find", "get", "getenv", "iand", "icom", "image", "insert", 
  377.         "integer", "ior", "ishift", "ixor", "key", "left", "list", "many", 
  378.         "map", "match", "member", "move", "name", "numeric", "open", "ord", 
  379.         "pop", "pos", "proc", "pull", "push", "put", "read", "reads", "real", 
  380.         "remove", "rename", "repl", "reverse", "right", "runerr", "seek", "seq", 
  381.         "set", "sort", "stop", "string", "tab", "table", "trim", "type", "upto", 
  382.         "variable", "where", "write", "writes", "system", "callout", "acos", 
  383.         "asin", "atan", "cos", "tor", "exp", "log", "rtod", "sin", "sqrt", 
  384.         "tan", "getch", "getche", "kbhit", "IntPeek", "Poke", "GetSpace", 
  385.         "FreeSpace", "InPort", "OutPort", "mmout", "mmpause", "mmshow" ]
  386.     every builtin_tab[!builtin] := 1
  387.     
  388. end
  389.  
  390. procedure line_number()
  391.  
  392.                     # LINE_NUMBER SEQ
  393.                     
  394.                         lineno := &null
  395.                         line ? {
  396.                             cstar(ws) & ="line" & cplus(ws) &
  397.                             (lineno <- integer(tab(many(&digits)))) &
  398.                             cstar(ws) & pos(0)
  399.                         }
  400.                         \lineno | stop(&errout, "Invalid Source Line Number Line: ", line)
  401.                     
  402.                         write(line)
  403.                         
  404.                         if not (
  405.                             curproc == debug_proc_name |
  406.                             (
  407.                                 \includes & /include_procs[curproc]
  408.                             )
  409.                         ) then {
  410.                         
  411.                             # Install __vals := []
  412.                             write("\tmark\t", save_label := next_label())
  413.                             write("\tpnull")
  414.                             write("\tvar\t", val_list_id)
  415.                             write("\tpnull")
  416.                             write("\tllist\t0")
  417.                             write("\tasgn")
  418.                             write("\tunmark")
  419.                             write("lab ", save_label)
  420.                             
  421.                             # Install every put(_vals, variable(!__names))
  422.                             write("\tmark\t", save_label := next_label())
  423.                             write("\tmark0")
  424.                             write("\tvar\t", put_id)
  425.                             write("\tvar\t", val_list_id)
  426.                             write("\tvar\t", variable_id)
  427.                             write("\tpnull")
  428.                             write("\tvar\t", name_list_id)
  429.                             write("\tbang")
  430.                             write("\tinvoke\t1")
  431.                             write("\tinvoke\t2")
  432.                             write("\tpop")
  433.                             write("lab ",next_label())
  434.                             write("\tefail")
  435.                             write("lab ",next_label())
  436.                             write("\tunmark")
  437.                             write("lab ",save_label)
  438.  
  439.                             
  440.                             # Install __debug_proc(&file, <proc_name>, &line, __names, __vals)
  441.                             write("\tmark\t", save_label := next_label())
  442.                             write("\tvar\t", debug_proc_id)
  443.                             write("\tkeywd\t", andfileid)
  444.                             write("\tstr\t", proc_name_id)
  445.                             write("\tkeywd\t", andlineid)
  446.                             write("\tvar\t", name_list_id)
  447.                             write("\tvar\t", val_list_id)
  448.                             write("\tinvoke\t5")
  449.                             write("\tunmark")
  450.                             write("lab ",save_label)
  451.                             
  452.                             # Install
  453.                             #   every __i := 1 to *__names do
  454.                             #       variable(__names[__i]) := __vals[__i]
  455.                             if \modify then {
  456.                                 write("\tmark\t", save_label := next_label())
  457.                                 write("\tmark0")
  458.                                 write("\tpnull")
  459.                                 write("\tvar\t", index_id)
  460.                                 write("\tpnull")
  461.                                 write("\tint\t", one_id)
  462.                                 write("\tpnull")
  463.                                 write("\tvar\t", name_list_id)
  464.                                 write("\tsize")
  465.                                 write("\tpush1")
  466.                                 write("\ttoby")
  467.                                 write("\tasgn")
  468.                                 write("\tpop")
  469.                                 write("\tmark0")
  470.                                 write("\tpnull")
  471.                                 write("\tvar\t", variable_id)
  472.                                 write("\tpnull")
  473.                                 write("\tvar\t", name_list_id)
  474.                                 write("\tvar\t", index_id)
  475.                                 write("\tsubsc")
  476.                                 write("\tinvoke\t1")
  477.                                 write("\tpnull")
  478.                                 write("\tvar\t", val_list_id)
  479.                                 write("\tvar\t", index_id)
  480.                                 write("\tsubsc")
  481.                                 write("\tasgn")
  482.                                 write("\tunmark")
  483.                                 write("lab ", next_label())
  484.                                 write("\tefail")
  485.                                 write("lab ", next_label())
  486.                                 write("\tunmark")
  487.                                 write("lab ", save_label)
  488.                             }
  489.                                             
  490.                         }
  491.                         
  492.                         line := (read(tmpfile) | &null)
  493.  
  494.                     
  495.                     # LINE_NUMBER END
  496.  
  497. end
  498.  
  499. procedure line_body()
  500.  
  501.                     # LINE_BODY ITR UNTIL EOF OR END OF SOURCE LINE
  502.                     until (
  503.                         /line |
  504.                         ( line ? (cstar(ws) & ="proc" & cplus(ws)) ) |
  505.                         ( line ? (cstar(ws) & ="line" & cplus(ws)) )
  506.                     ) do {
  507.                     
  508.                         # OTHER_LINES SEQ
  509.                         
  510.                         write(line)
  511.                         
  512.                         line := (read(tmpfile) | &null)
  513.                         
  514.                         # OTHER_LINES END
  515.                         
  516.                     # LINE_BODY END
  517.                     }
  518.  
  519. end
  520.  
  521. procedure process_options(argv)
  522.  
  523.     local i, numfiles
  524.     
  525.     i := 1
  526.     numfiles := 0
  527.  
  528.     while i <= *argv do {
  529.     
  530.         case argv[i] of {
  531.         
  532.             "-i": {
  533.             
  534.                 includes := 1
  535.                 i +:= 1
  536.                 if i > *argv then stop(&errout, "Procedure name expected after -i option")
  537.                 include_procs[argv[i]] := 1
  538.                 
  539.             }
  540.         
  541.             "-m": {
  542.             
  543.                 modify := 1
  544.                 
  545.             }
  546.         
  547.             default: {
  548.             
  549.                 if (argv[i] ? ="-") & *argv[i] > 1 then stop(&errout, "Unknown option: ", argv[i])
  550.             
  551.                 infile_name := argv[i]
  552.                 numfiles +:= 1
  553.                 if numfiles > 1 then stop(&errout, "Only one input file name allowed on command line")
  554.             
  555.             }
  556.         
  557.         }
  558.         
  559.         i +:= 1
  560.         
  561.     }
  562.  
  563.  
  564. end
  565.  
  566.   
  567.